home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / pcl / sptmbr11.lha / clcs / install.lisp < prev    next >
Lisp/Scheme  |  1992-03-28  |  4KB  |  103 lines
  1. ;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: "CONDITIONS"; Base: 10 -*-
  2.  
  3. (in-package "CONDITIONS")
  4.  
  5. (defvar *shadowed-symbols* 
  6.   '(BREAK ERROR CERROR WARN CHECK-TYPE ASSERT ETYPECASE CTYPECASE ECASE CCASE))
  7.  
  8. (defun install-symbol (real clcs)
  9.   (unless (get real ':definition-before-clcs)
  10.     (setf (get real ':definition-before-clcs)
  11.       (symbol-function real)))
  12.   (unless (eq (symbol-function real)
  13.           (symbol-function clcs))           
  14.     (setf (symbol-function real)
  15.       (symbol-function clcs))))
  16.  
  17. (defun revert-symbol (real)
  18.   (when (and (get real ':definition-before-clcs)
  19.          (not (eq (symbol-function real)
  20.               (get real ':definition-before-clcs))))
  21.     (setf (symbol-function real)
  22.       (get real ':definition-before-clcs))))
  23.  
  24. (defvar *clcs-redefinitions*
  25.   (nconc (mapcar #'(lambda (symbol)
  26.              (list (intern (symbol-name symbol) "LISP") symbol))
  27.          *shadowed-symbols*)
  28.      '((compile-file clcs-compile-file)
  29.        (compile clcs-compile)
  30.            (load clcs-load)
  31.            (open clcs-open)
  32.        #+kcl (si::break-level si::clcs-break-level)
  33.        #+kcl (si::terminal-interrupt si::clcs-terminal-interrupt)
  34.        #+kcl (si::break-quit si::clcs-break-quit)
  35.        #+kcl (si::error-set clcs-error-set)
  36.        #+kcl (si::universal-error-handler clcs-universal-error-handler))))
  37.  
  38. (defun install-clcs-symbols ()
  39.   (dolist (r *clcs-redefinitions*)
  40.     (install-symbol (first r) (second r)))
  41.   nil)
  42.  
  43. (defun revert-clcs-symbols ()
  44.   (dolist (r (reverse *clcs-redefinitions*))
  45.     (revert-symbol (first r)))
  46.   nil)
  47.  
  48. (defun clcs-compile-file (file &rest args)
  49.   (loop (with-simple-restart (retry "Retry compiling file ~S." file)
  50.       (let ((values (multiple-value-list 
  51.                 (apply (or (get 'compile-file ':definition-before-clcs)
  52.                        #'compile-file)
  53.                    file args))))
  54.         (unless #+kcl compiler::*error-p* #-kcl nil
  55.           (return-from clcs-compile-file
  56.         (values-list values)))
  57.         (error "~S failed." 'compile-file)))))
  58.  
  59. (defun clcs-compile (&rest args)
  60.   (loop (with-simple-restart (retry "Retry compiling ~S." (car args))
  61.       (let ((values (multiple-value-list 
  62.                 (apply (or (get 'compile ':definition-before-clcs)
  63.                        #'compile-file)
  64.                    args))))
  65.         (unless #+kcl compiler::*error-p* #-kcl nil
  66.           (return-from clcs-compile
  67.         (values-list values)))
  68.         (error "~S failed." 'compile)))))
  69.  
  70. (defun clcs-load (file &rest args)
  71.   (loop (with-simple-restart (retry "Retry loading file ~S." file)
  72.           (return-from clcs-load 
  73.                        (apply (or (get 'load ':definition-before-clcs) #'load)
  74.                               file args)))))
  75.  
  76. (defun clcs-open (file &rest args)
  77.   (loop (with-simple-restart (retry "Retry opening file ~S." file)
  78.           (return-from clcs-open
  79.                        (apply (or (get 'open ':definition-before-clcs) #'open)
  80.                               file args)))))
  81.  
  82. #+(or kcl lucid cmu)
  83. (install-clcs-symbols)
  84.  
  85. (defun dsys::retry-operation (function retry-string)
  86.   (loop (with-simple-restart (retry retry-string)
  87.       (return-from dsys::retry-operation
  88.         (funcall function)))))
  89.  
  90. (defun dsys::operate-on-module (module initial-state system-operation)
  91.   (if (null dsys::*retry-operation-list*)
  92.       (dsys::operate-on-module1 module initial-state system-operation)
  93.       (let ((retry-operation (car (last dsys::*retry-operation-list*)))
  94.         (dsys::*retry-operation-list* (butlast dsys::*retry-operation-list*)))
  95.     (restart-bind ((retry 
  96.             #'(lambda (&rest ignore)
  97.                 (declare (ignore ignore))
  98.                 (funcall (car retry-operation)))
  99.             :report-function
  100.             #'(lambda (stream)
  101.                 (write-string (cdr retry-operation) stream))))
  102.        (dsys::operate-on-module module initial-state system-operation)))))
  103.